home *** CD-ROM | disk | FTP | other *** search
/ Gold Medal Software 2 / Gold Medal Software Volume 2 (Gold Medal) (1994).iso / database / bltq18.arj / BB_CIU10.BAS < prev    next >
BASIC Source File  |  1993-08-04  |  15KB  |  536 lines
  1.  
  2. DEFINT A-Z
  3.  
  4. REM $INCLUDE: 'BULLET.BI'
  5. 'bb_ciu10.bas 31-May-92 chh
  6. '--example using 8-char key, dups and         
  7. '--a second index of LONG INT (on SSN field), unique to check Update xaction
  8.  
  9. 'this example shows the transaction-based feature of UpdateXB--it purposely
  10. 'inserts to the two index files, and then will do Updates of already existing
  11. 'SSN key, thus causing all the Updates to be backed-out except the
  12. 'very last (since the last is changed in a way that no current key matches)
  13. 'See BB_CIN10.BAS for more on transaxtion-based info
  14.  
  15. 'this code is for a simplistic database
  16. 'it uses a single DBF (true DBF-compat) and two related indexes
  17. 'the first index is on the first 5 chars of last name + first char first name
  18. 'second index is on the SSN, since it's a valid LONG INT we use that key type
  19.  
  20. 'C>bc bb_ciu10 /o;
  21. 'C>link bb_ciu10,,nul,bullet;
  22.  
  23. UseDir$ = ".\"                  'all files use this directory except
  24.                                 'the reindex work file which uses the
  25.                                 'SET TMP= directory or the current directory
  26. CLS
  27. PRINT "BB_CIU10.BAS - 8-CHAR (DUPS) and LONG INT (UNIQUE), UpdateXB example"
  28. PRINT "--maintains *2* index files automatically, using NLS sorting."
  29. PRINT ">> USING DIRECTORY "; UseDir$
  30. PRINT
  31.  
  32. TYPE TestRecTYPE
  33. Tag AS STRING * 1
  34. FirstName AS STRING * 15        'a DBF C fieldtype
  35. LastName AS STRING * 19         'C
  36. SSN AS STRING * 9               'N (use C instead to use SUBSTR() on it)
  37. BDate AS STRING * 8             'D
  38. DeptNo AS STRING * 3            'C
  39. Salary AS STRING * 9            'N
  40. END TYPE '64                    'DBF III+ limit is 4000 bytes/128 fields
  41.                                 
  42. DIM DFP AS DOSFilePack
  43. DIM MP AS MemoryPack
  44. DIM IP AS InitPack
  45. DIM EP AS ExitPack
  46. DIM CDP AS CreateDataPack
  47. DIM CKP AS CreateKeyPack
  48. DIM OP AS OpenPack
  49. DIM AP(1 TO 2) AS AccessPack    '2 since we're maintaining 2 index files
  50. DIM SDP AS StatDataPack
  51. DIM SKP AS StatKeyPack
  52. DIM XEP AS XErrorPack
  53.  
  54. DIM FieldList(1 TO 6) AS FieldDescTYPE
  55. DIM TestRec AS TestRecTYPE
  56. DIM ZSTR AS STRING * 1
  57. DIM NameDAT AS STRING * 80      'DBF data file
  58. DIM NameIX1 AS STRING * 80      'first index file
  59. DIM NameIX2 AS STRING * 80      'second index file
  60. DIM KX1 AS STRING * 136         'key expression for first index file
  61. DIM KX2 AS STRING * 136         'key expression for second index file
  62. DIM KeyBuffer AS STRING * 64
  63.  
  64. DIM First$(1 TO 26)
  65. DIM Last$(1 TO 26)
  66. GOSUB FillNamesIn
  67.  
  68. ZSTR = CHR$(0)
  69. NameDAT = UseDir$ + "CHARTEST.DBF" + ZSTR
  70. NameIX1 = UseDir$ + "CHARTEST.IX1" + ZSTR
  71. NameIX2 = UseDir$ + "CHARTEST.IX2" + ZSTR
  72.  
  73. FieldList(1).FieldName = "FIRSTNAME" + ZSTR
  74. FieldList(1).FieldType = "C"
  75. FieldList(1).FieldLength = CHR$(15)
  76. FieldList(1).FieldDC = CHR$(0)
  77. FieldList(2).FieldName = "LASTNAME" + ZSTR + ZSTR
  78. FieldList(2).FieldType = "C"
  79. FieldList(2).FieldLength = CHR$(19)
  80. FieldList(2).FieldDC = CHR$(0)
  81. FieldList(3).FieldName = "SSN" + STRING$(7, 0)
  82. FieldList(3).FieldType = "N"
  83. FieldList(3).FieldLength = CHR$(9)
  84. FieldList(3).FieldDC = CHR$(0)
  85. FieldList(4).FieldName = "BDATE" + STRING$(5, 0)
  86. FieldList(4).FieldType = "D"
  87. FieldList(4).FieldLength = CHR$(8)
  88. FieldList(4).FieldDC = CHR$(0)
  89. FieldList(5).FieldName = "DEPTNO" + STRING$(4, 0)
  90. FieldList(5).FieldType = "C"
  91. FieldList(5).FieldLength = CHR$(3)
  92. FieldList(5).FieldDC = CHR$(0)
  93. FieldList(6).FieldName = "SALARY" + STRING$(4, 0)
  94. FieldList(6).FieldType = "N"
  95. FieldList(6).FieldLength = CHR$(9)
  96. FieldList(6).FieldDC = CHR$(2)
  97.  
  98. level = 100
  99. MP.Func = MemoryXB
  100. stat = BULLET(MP)
  101. IF MP.Memory < 140000 THEN
  102.     QBheap& = SETMEM(-150000)       'hog wild, 64K would do okay
  103.     MP.Func = MemoryXB
  104.     stat = BULLET(MP)
  105.     IF MP.Memory < 140000 THEN stat = 8: GOTO Abend
  106. END IF
  107. PRINT "free DGROUP:"; FRE(a$)
  108.  
  109. level = 110
  110. IP.Func = InitXB
  111. IP.JFTmode = 0
  112. stat = BULLET(IP)
  113. IF stat THEN GOTO Abend
  114.  
  115. level = 120
  116. EP.Func = AtExitXB
  117. stat = BULLET(EP)
  118.  
  119. level = 130
  120. DFP.Func = DeleteFileDOS
  121. DFP.FilenamePtrOff = VARPTR(NameDAT)
  122. DFP.FilenamePtrSeg = VARSEG(NameDAT)
  123. stat = BULLET(DFP)
  124. DFP.FilenamePtrOff = VARPTR(NameIX1)
  125. DFP.FilenamePtrSeg = VARSEG(NameIX1)
  126. stat = BULLET(DFP)
  127. DFP.FilenamePtrOff = VARPTR(NameIX2)
  128. DFP.FilenamePtrSeg = VARSEG(NameIX2)
  129. stat = BULLET(DFP)
  130.  
  131. level = 1000
  132. CDP.Func = CreateDXB
  133. CDP.FilenamePtrOff = VARPTR(NameDAT)
  134. CDP.FilenamePtrSeg = VARSEG(NameDAT)
  135. CDP.NoFields = 6
  136. CDP.FieldListPtrOff = VARPTR(FieldList(1))
  137. CDP.FieldListPtrSeg = VARSEG(FieldList(1))
  138. CDP.FileID = 3
  139. stat = BULLET(CDP)
  140. IF stat THEN GOTO Abend
  141.  
  142. level = 1010
  143. OP.Func = OpenDXB
  144. OP.FilenamePtrOff = VARPTR(NameDAT)
  145. OP.FilenamePtrSeg = VARSEG(NameDAT)
  146. OP.ASmode = ReadWrite + DenyNone
  147. stat = BULLET(OP)
  148. IF stat THEN GOTO Abend
  149. HandDAT = OP.Handle
  150.  
  151. level = 1100
  152. KX1 = "SUBSTR(LASTNAME,1,5)+SUBSTR(FIRSTNAME,1,1)"
  153. CKP.Func = CreateKXB
  154. CKP.FilenamePtrOff = VARPTR(NameIX1)
  155. CKP.FilenamePtrSeg = VARSEG(NameIX1)
  156. CKP.KeyExpPtrOff = VARPTR(KX1)
  157. CKP.KeyExpPtrSeg = VARSEG(KX1)
  158. CKP.XBlink = HandDAT
  159. CKP.KeyFlags = cCHAR
  160. CKP.CodePageID = -1
  161. CKP.CountryCode = -1
  162. CKP.CollatePtrOff = 0
  163. CKP.CollatePtrSeg = 0
  164. stat = BULLET(CKP)
  165. IF stat THEN GOTO Abend
  166.  
  167. level = 1102
  168. KX2 = "SSN"
  169. CKP.Func = CreateKXB
  170. CKP.FilenamePtrOff = VARPTR(NameIX2)
  171. CKP.FilenamePtrSeg = VARSEG(NameIX2)
  172. CKP.KeyExpPtrOff = VARPTR(KX2)
  173. CKP.KeyExpPtrSeg = VARSEG(KX2)
  174. CKP.XBlink = HandDAT
  175. CKP.KeyFlags = cLONG + cSIGNED + cUNIQUE 'test transaction ability by forcing
  176. CKP.CodePageID = -1                      'duplicate SSN numbers
  177. CKP.CountryCode = -1
  178. CKP.CollatePtrOff = 0
  179. CKP.CollatePtrSeg = 0
  180. stat = BULLET(CKP)
  181. IF stat THEN GOTO Abend
  182.  
  183. level = 1110
  184. OP.Func = OpenKXB
  185. OP.FilenamePtrOff = VARPTR(NameIX1)
  186. OP.FilenamePtrSeg = VARSEG(NameIX1)
  187. OP.ASmode = ReadWrite + DenyNone
  188. OP.xbHandle = HandDAT
  189. stat = BULLET(OP)
  190. IF stat THEN GOTO Abend
  191. HandIX1 = OP.Handle
  192.  
  193. level = 1112
  194. OP.Func = OpenKXB
  195. OP.FilenamePtrOff = VARPTR(NameIX2)
  196. OP.FilenamePtrSeg = VARSEG(NameIX2)
  197. OP.ASmode = ReadWrite + DenyNone
  198. OP.xbHandle = HandDAT
  199. stat = BULLET(OP)
  200. IF stat THEN GOTO Abend
  201. HandIX2 = OP.Handle
  202.  
  203. AP(1).Func = InsertXB
  204. AP(1).Handle = HandIX1
  205. AP(1).RecPtrOff = VARPTR(TestRec)
  206. AP(1).RecPtrSeg = VARSEG(TestRec)
  207. AP(1).KeyPtrOff = VARPTR(KeyBuffer)
  208. AP(1).KeyPtrSeg = VARSEG(KeyBuffer)
  209. AP(1).NextPtrOff = VARPTR(AP(2))
  210. AP(1).NextPtrSeg = VARSEG(AP(2))
  211. AP(2).Func = InsertXB
  212. AP(2).Handle = HandIX2
  213. AP(2).RecPtrOff = VARPTR(TestRec)
  214. AP(2).RecPtrSeg = VARSEG(TestRec)
  215. AP(2).KeyPtrOff = VARPTR(KeyBuffer)
  216. AP(2).KeyPtrSeg = VARSEG(KeyBuffer)
  217. AP(2).NextPtrOff = 0
  218. AP(2).NextPtrSeg = 0
  219.  
  220. level = 1200
  221. 'keep Recs to insert below 1000 since there SSN values generated in this
  222. 'example range from 100000000 to 1000000999
  223.  
  224. INPUT "(suggest no more than 1000) Recs to insert:"; Recs2Add&
  225. PRINT "Inserting record:";
  226. herecol = POS(0)
  227.  
  228. 'these are not key values so just make them constant for this example
  229.  
  230. TestRec.Tag = " "
  231. TestRec.BDate = "19331122"   'yes, everyone is the same age
  232. TestRec.DeptNo = "001"       'yes, same dept too
  233. TestRec.Salary = "125000.77" 'and even the same salary
  234.  
  235. 'RANDOMIZE TIMER
  236. level = 1200
  237. GOSUB StartTimer
  238. FOR Recs& = 1 TO Recs2Add&
  239.  
  240.    'we want to know what's being used so we can verify that all was restored
  241.  
  242.    TestRec.FirstName = First$(1 + Recs& MOD 25)
  243.    TestRec.LastName = Last$(1 + Recs& MOD 25)
  244.    TestRec.SSN = STR$(Recs&)
  245.  
  246.    stat = 0
  247.    LOCATE , herecol
  248.    PRINT Recs&;
  249.  
  250.    sidx = BULLET(AP(1))
  251.    IF sidx = 0 AND AP(1).stat THEN
  252.       'error on data record add portion of insert
  253.       stat = AP(1).stat
  254.       GOTO Abend                        'consider this a fatal error
  255.    ELSEIF sidx THEN
  256.       stat = AP(sidx).stat
  257.       IF stat <> 201 THEN
  258.          GOTO Abend                     'this too
  259.       ELSE  'key already exists test    'a key already exists just skip
  260.          'won't happen in this example since we have duplicates okay
  261.          'for the first index file
  262.          STOP
  263.       END IF
  264.    END IF
  265.  
  266. NEXT
  267. GOSUB EndTimer
  268. LOCATE , 60
  269. PRINT "..."; secs&; "secs."
  270.  
  271.  
  272. PRINT  'show the first 5 data record in recno order (original data)
  273. PRINT "...the first 5 recs data file (original, before UpdateXB)"
  274. CIX = 1
  275. AP(1).Func = GetRecordXB
  276. AP(1).Handle = HandDAT
  277. FOR i = 1 TO 5
  278.    AP(1).Recno = i
  279.    stat = BULLET(AP(1))
  280.    GOSUB DispRecord
  281. NEXT
  282. IF stat = 202 THEN stat = 0
  283. IF stat THEN GOTO Abend
  284. PRINT
  285.  
  286. PRINT
  287. PRINT "...the last 5 recs data file "
  288. AP(1).Func = GetRecordXB
  289. FOR i = Recs2Add& TO Recs2Add& - 4 STEP -1
  290.    AP(1).Recno = i
  291.    stat = BULLET(AP(1))
  292.    GOSUB DispRecord
  293. NEXT
  294. IF stat = 202 THEN stat = 0
  295. IF stat THEN GOTO Abend
  296. PRINT
  297. PRINT "* Press any key to update";
  298. DO: LOOP UNTIL LEN(INKEY$)
  299. LOCATE , 1
  300.  
  301. dups = 0
  302. PRINT " Updating record:";
  303. herecol = POS(0)
  304.  
  305. GOSUB StartTimer
  306. FOR Recs& = 1 TO Recs2Add&
  307.  
  308.    AP(1).Func = GetRecordXB     'get the next data record
  309.    AP(1).Handle = HandDAT
  310.    AP(1).Recno = Recs&
  311.    'AP(2).Recno = Recs&          'UpdateXB always uses AP(1).Recno as recno
  312.  
  313.    stat = BULLET(AP(1))
  314.  
  315.    'leave first index as is (UpdateXB won't modify the first
  316.    '                         index file because the key field doesn't change)
  317.    'TestRec.FirstName = First$(2 + Recs& MOD 24) 'change IX1 key field by using
  318.    'TestRec.LastName = Last$(2 + Recs& MOD 24)   'next key's value
  319.  
  320.    'change the second index's key and show how the first is restored
  321.    'since this SSN already exists (except for the very last record updated)
  322.    '--the change is a simple "current + 1" which equal the following...
  323.    '...this just to easily show the xaction control
  324.  
  325.    TestRec.SSN = STR$(Recs& + 1)                'for SSN key field, too
  326.  
  327.    stat = 0
  328.    LOCATE , herecol
  329.    PRINT Recs&;
  330.  
  331.    level = 1250
  332.    AP(1).Func = UpdateXB
  333.    'AP(2).Func = UpdateXB                'UpdateXB always uses AP(1).Func
  334.    AP(1).Handle = HandIX1
  335.    sidx = BULLET(AP(1))
  336.    IF sidx = 0 AND AP(1).stat THEN
  337.       'error on data record add portion of insert
  338.       stat = AP(1).stat
  339.       GOTO Abend                        'consider this a fatal error
  340.    ELSEIF sidx THEN
  341.       stat = AP(sidx).stat
  342.       IF stat <> 201 THEN
  343.          GOTO Abend                     'this too
  344.       ELSE  'key already exists test    'a key already exists
  345.          dups = dups + 1                'for this example--it backs out the
  346.          PRINT "   SSN dups/Updates backed-out:"; dups;
  347.          stat = 0
  348.       END IF
  349.    END IF
  350.  
  351. NEXT
  352. GOSUB EndTimer
  353. LOCATE , 60
  354. PRINT "..."; secs&; "secs."
  355. PRINT
  356. PRINT "DUPS cnt="; dups;
  357. GOSUB ShowStats
  358.  
  359. PRINT
  360. PRINT "* Press any key to see first/last 5 record";
  361. DO: LOOP UNTIL LEN(INKEY$)
  362. LOCATE , 1
  363.  
  364. CIX = 1
  365. level = 1290
  366. PRINT "...the first 5 recs data file (after UpdateXB)"
  367. AP(1).Func = GetRecordXB
  368. AP(1).Handle = HandDAT
  369. FOR i = 1 TO 5
  370.    AP(1).Recno = i
  371.    stat = BULLET(AP(1))
  372.    GOSUB DispRecord
  373. NEXT
  374. IF stat = 202 THEN stat = 0
  375. IF stat THEN GOTO Abend
  376. PRINT
  377.  
  378. level = 1292
  379. PRINT
  380. PRINT "...the last 5 recs data file "
  381. AP(1).Func = GetRecordXB
  382. FOR i = Recs2Add& TO Recs2Add& - 4 STEP -1
  383.    AP(1).Recno = i
  384.    stat = BULLET(AP(1))
  385.    GOSUB DispRecord
  386. NEXT
  387. IF stat = 202 THEN stat = 0
  388. IF stat THEN GOTO Abend
  389. PRINT
  390. PRINT "Note that only the very last SSN update took effect (the first of the last 5)."
  391. PRINT "All the others were backed-out and restored to the original state. Okay."
  392. EndIt:
  393. EP.Func = ExitXB
  394. stat = BULLET(EP)
  395. END
  396.  
  397.  
  398. Abend:
  399. PRINT
  400. PRINT "Error:"; stat; "at level"; level; "while performing ";
  401. SELECT CASE level
  402. CASE IS = 999
  403.    SELECT CASE level
  404.    CASE 100
  405.       PRINT "a memory request of 150K."
  406.    CASE 110
  407.       PRINT "BULLET initialization."
  408.    CASE 120
  409.       PRINT "registering of ExitXB with _atexit."
  410.    CASE ELSE
  411.       PRINT "Preliminaries unknown."
  412.    END SELECT
  413. CASE IS <= 1099
  414.    SELECT CASE level
  415.    CASE 1000
  416.       PRINT "data file create."
  417.    CASE 1010
  418.       PRINT "data file open."
  419.    CASE ELSE
  420.       PRINT "data file unknown."
  421.    END SELECT
  422. CASE IS <= 1199
  423.    SELECT CASE level
  424.    CASE 1100
  425.       PRINT "first index file create."
  426.    CASE 1102
  427.       PRINT "second index file create."
  428.    CASE 1110
  429.       PRINT "first index file open."
  430.    CASE 1112
  431.       PRINT "second index file open."
  432.    CASE ELSE
  433.       PRINT "index file unknown."
  434.    END SELECT
  435. CASE IS <= 1299
  436.    SELECT CASE level
  437.    CASE 1200
  438.       PRINT "inserting records."
  439.    CASE 1250
  440.       PRINT "updating records."
  441.    CASE ELSE
  442.       PRINT "getting unknown."
  443.    END SELECT
  444. CASE IS <= 1399
  445.    SELECT CASE level
  446.    CASE ELSE
  447.       PRINT "Get/unknown."
  448.    END SELECT
  449. CASE ELSE
  450.    PRINT "unknown."
  451. END SELECT
  452. GOTO EndIt
  453.  
  454. '----------
  455. ShowStats:
  456. SDP.Func = StatDXB
  457. SDP.Handle = HandDAT
  458. stat = BULLET(SDP)
  459. IF stat = 0 THEN
  460.    PRINT "Records:"; SDP.Recs;
  461.    SKP.Func = StatKXB
  462.    SKP.Handle = HandIX1
  463.    stat = BULLET(SKP)
  464.    IF stat = 0 THEN
  465.       PRINT " IX1:keys:"; SKP.Keys;
  466.       SKP.Func = StatKXB
  467.       SKP.Handle = HandIX2
  468.       stat = BULLET(SKP)
  469.       IF stat = 0 THEN
  470.          PRINT " IX2:keys:"; SKP.Keys
  471.       ELSE
  472.          PRINT "*IX2:StatKXB"; stat
  473.       END IF
  474.    ELSE
  475.       PRINT "*IX1:StatKXB"; stat
  476.    END IF
  477. ELSE
  478.    PRINT "*DBF:StatDXB"; stat
  479. END IF
  480. RETURN
  481.  
  482. DispRecord:
  483. t$ = SPACE$(79)
  484. MID$(t$, 1, 6) = RIGHT$("     " + LTRIM$(STR$(AP(CIX).Recno)), 6)
  485. MID$(t$, 7, 1) = TestRec.Tag
  486. t2$ = RTRIM$(TestRec.LastName) + ", " + RTRIM$(TestRec.FirstName)
  487. MID$(t$, 8, 30) = t2$
  488. t2$ = MID$(TestRec.SSN, 1, 3) + "-" + MID$(TestRec.SSN, 4, 2) + "-" + MID$(TestRec.SSN, 6, 4)
  489. MID$(t$, 40, 9) = t2$
  490. t2$ = MID$(TestRec.BDate, 5, 2) + "/" + MID$(TestRec.BDate, 7, 2) + "/" + MID$(TestRec.BDate, 3, 2)
  491. MID$(t$, 53, 8) = t2$
  492. MID$(t$, 63, 3) = TestRec.DeptNo
  493. MID$(t$, 68, 9) = TestRec.Salary
  494. PRINT t$
  495. RETURN
  496.  
  497. StartTimer:
  498. DEF SEG = &H40
  499. lb1 = PEEK(&H6C)
  500. hb1 = PEEK(&H6D)
  501. lb2 = PEEK(&H6E)
  502. DEF SEG
  503. stime& = CVL(CHR$(lb1) + CHR$(hb1) + CHR$(lb2) + ZSTR)
  504. RETURN
  505.  
  506. EndTimer:
  507. DEF SEG = &H40
  508. lb1 = PEEK(&H6C)
  509. hb1 = PEEK(&H6D)
  510. lb2 = PEEK(&H6E)
  511. DEF SEG
  512. etime& = CVL(CHR$(lb1) + CHR$(hb1) + CHR$(lb2) + ZSTR)
  513. secs& = ((etime& - stime&) * 10) \ 182
  514. RETURN
  515.  
  516. FillNamesIn:
  517. FOR i = 1 TO 26
  518.    READ F$
  519.    First$(i) = F$ + SPACE$(15)  'space-fill names
  520. NEXT
  521. FOR i = 1 TO 26
  522.    READ L$
  523.    Last$(i) = L$ + SPACE$(19)
  524. NEXT
  525. RETURN
  526.  
  527. DATA "Arturo","Bebe","Clarisa","Diamond","Eve","Franklin","Gweny","Horatio"
  528. DATA "Iggie","Jammal","Kevin","Legs","Michelle","Nova","Obar","Pepi","Quartz"
  529. DATA "Raul","Santa","Thomas","Uve","Vue","Winchester","Xeba","Yve","Zanzi"
  530.  
  531. DATA "Abelson","ABELSON","Charlieson","Deltason","Epsilson","Foxson","Gamson","Hydra"
  532. DATA "Manson","Jumpson","Kiloson","Loxson", "Moonson","Noson","Octson"
  533. DATA "Pepson","Quarterson","Renoson","Salvoson","Tooson","Underson","Vulcanson"
  534. DATA "Weaverson","Xanson","ZENDASON","Zendason"
  535.  
  536.